﻿
Const ProgID = "ComTest"
Const CLSID_Com = "{920DCEED-B3DD-4110-8F2F-981A554E07FF}"
'Event--------
Const IID___Com = "{62DD544B-09E0-4340-8FF8-41CCC0FD0666}"

Type IClassFactoryImp Extends IClassFactoryVtbl
   Declare Constructor()
End Type


Function IClassFactoryx_QueryInterface(ByVal This As IClassFactory Ptr, ByVal riid As REFIID, ByVal ppvObject As LPVOID Ptr) As HRESULT
   if IsEqualIID(riid, @IID_IUnknown) Then
   ElseIf IsEqualIID(riid, @IID_IDispatch) Then
   ElseIf IsEqualIID(riid, @IID_IClassFactory) Then
   elseif (IsEqualIID(riid, @IID_IConnectionPointContainer)) Then
      MsgBox "控件"
   Else
      RETURN E_NOINTERFACE
   End If
    *ppvObject = This
   Return S_OK
End Function

Function IClassFactoryx_AddRef(ByVal This As IClassFactory Ptr) As HRESULT
   Return S_OK
End Function

Function IClassFactoryx_Release(byVal This As IClassFactory Ptr) As HRESULT
   Return S_OK
End Function

Function IClassFactoryx_CreateInstance(byval This as IClassFactory ptr, byval pUnkOuter as IUnknown ptr, byval riid as const IID const ptr, byval ppvObject as any ptr ptr) as HRESULT
   if IsEqualIID(riid, @IID_IUnknown) Then
   ElseIf IsEqualIID(riid, @IID_IDispatch) Then
   ElseIf IsEqualIID(riid, @IID_IClassFactory) Then
       *ppvObject = this
      Return S_OK
   Else
      RETURN E_NOINTERFACE
   End If
   dim IDB As IDispatch ptr = New IDispatch
   IDB->lpVtbl = New Demo()
   *ppvObject = IDB
   IUnknown_Release(IDB)
   return S_OK
End Function

Function IClassFactoryx_LockServer(byval This as IClassFactory ptr, byval fLock as WINBOOL) as HRESULT
   return S_OK
End Function

Constructor IClassFactoryImp()
   This.QueryInterface = @IClassFactoryx_QueryInterface '0
   This.AddRef = @IClassFactoryx_AddRef '4
   This.Release = @IClassFactoryx_Release '8
   This.CreateInstance = @IClassFactoryx_CreateInstance '12
   This.LockServer = @IClassFactoryx_LockServer '16
End Constructor

Type Demo Extends IDispatchVtbl
   
   TestOpen As function(ByVal This As IDispatch Ptr) As HRESULT'32
   Declare Constructor()
End Type

Function Demo_QueryInterface(ByVal This As IDispatch PTR, ByVal riid As REFIID, ByVal ppvObject As LPVOID Ptr) As HRESULT
   if IsEqualIID(riid, @IID_IUnknown) Then
   ElseIf IsEqualIID(riid, @IID_IDispatch) Then
   elseif (IsEqualIID(riid, @IID_IConnectionPointContainer)) Then
      MsgBox "这是要找控件"
   Else
      RETURN E_NOINTERFACE
   End If
    *ppvObject = This
   Return S_OK
End Function

Function Demo_AddRef(ByVal This As IDispatch PTR) As HRESULT
   Return S_OK
End Function

Function Demo_Release(ByVal This As IDispatch PTR) As HRESULT
   Return S_OK
End Function

Function Demo_GetTypeInfoCount(ByVal This As IDispatch PTR, ByVal pctinfo As UINT Ptr) As HRESULT
    *pctinfo = 0
'   MsgBox "Demo_GetTypeInfoCount"
   Return S_OK
End Function

Function Demo_GetTypeInfo(ByVal This As IDispatch PTR, ByVal iTInfo As UINT, ByVal lcid As LCID, ByVal ppTInfo As ITypeInfo Ptr Ptr) As HRESULT
'   Dim TI As ITypeInfo Ptr=New ITypeInfo
'   TI->lpVtbl=new TypeInfoImp
'   *ppTInfo=TI
'   MsgBox "Demo_GetTypeInfo"
   Return S_OK
End Function

Function Demo_GetIDsOfNames(ByVal This As IDispatch PTR, ByVal riid As Const IID Const Ptr, ByVal rgszNames As LPOLESTR Ptr, ByVal cNames As UINT, ByVal lcid As LCID, ByVal rgDispId As DISPID Ptr) As HRESULT
   Select case *rgszNames[0]
      Case "Add"
          *rgDispId = 1
   End Select
   Return S_OK
End Function

Function Demo_Invoke(ByVal This As IDispatch PTR, ByVal dispIdMember As DISPID, ByVal riid As Const IID Const Ptr, ByVal lcid As LCID, ByVal wFlags As WORD, ByVal pDispParams As DISPPARAMS Ptr, ByVal pVarResult As VARIANT Ptr, ByVal pExcepInfo As EXCEPINFO Ptr, ByVal puArgErr As UINT Ptr) As HRESULT
   Dim p As Parameters
   p.Count = pDispParams->cArgs
   if p.Count > 0 then
      ReDim p.Item(p.Count -1)
      For i As Long = 0 to pDispParams->cArgs -1
         p.Item(i).Value = pDispParams->rgvarg[i]
      Next
   end if
   select case dispIdMember
      Case 1
         Dim r As Long
         r = p.Item(0).Value.lVal + p.Item(1).Value.lVal
          *pVarResult = CVAR(r)
   End Select
   Return S_OK
End Function

Function Demo_Open(ByVal This As IDispatch PTR) As HRESULT
   MsgBox"test"
   Return S_OK
End Function

Constructor Demo()
   This.QueryInterface = @Demo_QueryInterface '0
   This.AddRef = @Demo_AddRef '4
   This.Release = @Demo_Release '8
   This.GetTypeInfoCount = @Demo_GetTypeInfoCount '12
   This.GetTypeInfo = @Demo_GetTypeInfo '16
   This.GetIDsOfNames = @Demo_GetIDsOfNames '20
   This.Invoke = @Demo_Invoke '24
   This.TestOpen = @Demo_Open '28
End Constructor

Sub test()
   Dim IDB As IDispatch Ptr = New IDispatch
   IDB->lpVtbl = New Demo
   Dim ret As VARIANT
   DispCallFunc(IDB, 28, 1, vbLong, 0, 0, 0, @ret)
End sub